{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.Syntax
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax.
--
--------------------------------------------------------------------------------

module WumpusExpr.Syntax 
  ( 

    Program(..)
  , Fundef(..)
  , Expr(..)
  , Command(..)  

  , typeOf

  , ppProgram

  ) where

import WumpusExpr.Operators hiding ( binDocE, unaryDocE )
import WumpusExpr.Radian
import WumpusExpr.Types
import WumpusExpr.Utils
import WumpusExpr.VarId

import Text.PrettyExprHPJ.Haskell98             -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ                -- package: pretty


data Program = Program 
      { proc_main :: Fundef 
      , proc_defs :: [Fundef]
      }
  deriving (Eq,Show)



data Fundef = Fundef 
    { fun_name       :: VarId
    , fun_args       :: [VarId]
    , fun_body       :: Expr
    } 
  deriving (Eq, Show)


infixl 1 :>>


-- | Expression type with effects - tracing output and updating 
-- the graphics state. 
-- 
-- Note - the graphics state is not introspective so it does
-- not support monadic bind, just monadic sequence.
-- 
data Expr = Unit
          | Bool Bool
          | Int Int
          | Float Decimal
          | Angle Radian
          | String String
          | PsSymbol String
          | Var VarId
          | Let VarId Expr Expr
          | UnaryE UnaryOp Expr
          | BinE BinOp Expr Expr
          | RelE RelOp Expr Expr
          | Ifte Expr Expr Expr
          | App Expr [Expr]
          | Cmd Command         -- command is monadic, c.f tell (writer)
          | Expr :>> Expr       -- monadic sequencing
          | Return Expr         -- monadic return
  deriving (Eq, Show)


data Command = NewPath
             | ClosePath
             | Fill
             | Stroke
             | MoveTo Expr Expr
             | LineTo Expr Expr
             | CurveTo Expr Expr Expr Expr Expr Expr
             | GSave
             | GRestore
             | Scale Expr Expr
             | Rotate Expr
             | Translate Expr Expr
             | Transform Expr Expr Expr Expr Expr Expr
             | ShowText Expr
  deriving (Eq,Show)

  -- TODO colour handling seems different between 
  -- PostScript and Canvas...


typeOf :: Expr -> Type
typeOf (Unit)                   = TyUnit
typeOf (Bool {})                = TyBool
typeOf (Int {})                 = TyInt
typeOf (Float {})               = TyFloat
typeOf (Angle {})               = TyRadian
typeOf (String {})              = TyString
typeOf (PsSymbol {})            = TyPsSymbol
typeOf (Var v)                  = varType v
typeOf (Let _ _ e2)             = typeOf e2
typeOf (UnaryE _ e)             = typeOf e    -- assume type preserving
typeOf (BinE _ _ e2)            = typeOf e2   -- assume type preserving
typeOf (RelE {})                = TyBool
typeOf (Ifte _ _ e3)            = typeOf e3
typeOf (App v _)                = 
    case typeOf v of { TyFun _ a -> a; t -> t }

typeOf (Cmd {})                 = TyMon TyUnit
typeOf (_ :>> e2)               = TyMon $ typeOf e2
typeOf (Return e)               = TyMon $ typeOf e

--------------------------------------------------------------------------------
-- Pretty print

ppProgram :: Program -> Doc
ppProgram (Program main_proc defs) = 
    vcatBlank $ map ppFundef (main_proc : defs)


ppFundef :: Fundef -> Doc
ppFundef (Fundef hd args e) = 
    text "def" <+> ppVarId hd <+> hsep (map ppVarId args) <+> char '=' 
      $+$ nest 2 (ppExpr e)



ppExpr :: Expr -> Doc
ppExpr = unparse . exprDoc

exprDoc :: Expr -> DocE
exprDoc Unit                  = literal "()"
exprDoc (Bool b)              = if b then literal "true" else literal "false"
exprDoc (Int i)               = Atom $ int i 
exprDoc (Float d)             = Atom $ truncatedDouble $ realToFrac d
exprDoc (Angle r)             = Atom $ truncatedDouble $ realToFrac r
exprDoc (String s)            = Atom $ doubleQuotes $ text s
exprDoc (PsSymbol s)          = Atom $ text ('/':s)
exprDoc (UnaryE op e)         = unaryDocE op (exprDoc e)
exprDoc (BinE op e1 e2)       = binDocE op (exprDoc e1) (exprDoc e2)
exprDoc (RelE op e1 e2)       = relDocE op (exprDoc e1) (exprDoc e2)

-- if actually has precedence 2....
exprDoc (Ifte e1 e2 e3)       = 
    Atom $ text "if" <+> ppExpr e1 <+> text "then" <+> ppExpr e2 
                                   <+> text "else" $+$ ppExpr e3

exprDoc (Let xt e1 e2)        = 
    Atom $ text "let" <+> (ppBind xt e1) <+> text "in" <+> ppExpr e2

exprDoc (Var x)              = Atom $ ppVarId x

exprDoc (App e es)           = funAppB (exprDoc e) (map exprDoc es)

exprDoc (Cmd cmd)            = ppCommandE cmd

exprDoc (e1 :>> e2)          = 
    Atom $ ppExpr e1 <> char ';' $+$ ppExpr e2

exprDoc (Return e)           = funAppB1 (literal "return") (exprDoc e)


ppBind :: VarId -> Expr -> Doc
ppBind x e = ppVarId x <+> char '=' <+> ppExpr e


ppCommandE :: Command -> DocE
ppCommandE (NewPath)                    = funAppB (literal "newpath") []
ppCommandE (ClosePath)                  = funAppB (literal "closepath") []
ppCommandE (Fill)                       = funAppB (literal "fill") []
ppCommandE (Stroke)                     = funAppB (literal "stroke") []
ppCommandE (MoveTo x y)                 = 
    funAppB (literal "moveto") (map exprDoc [x,y])

ppCommandE (LineTo x y)                 = 
    funAppB (literal "lineto") (map exprDoc [x,y])

ppCommandE (CurveTo x1 y1 x2 y2 x3 y3)  =
    funAppB (literal "curveto") (map exprDoc [x1,y1,x2,y2,x3,y3])

ppCommandE (GSave)                      = funAppB (literal "gsave") []
ppCommandE (GRestore)                   = funAppB (literal "grestore") []
ppCommandE (Scale x y)                  = 
    funAppB (literal "scale") (map exprDoc [x,y])

ppCommandE (Rotate ang)                 = 
    funAppB (literal "rotate") [exprDoc ang]

ppCommandE (Translate x y)              = 
    funAppB (literal "translate") (map exprDoc [x,y])

ppCommandE (Transform a b c d e f)      = 
    funAppB (literal "transform") (map exprDoc [a,b,c,d,e,f])

ppCommandE (ShowText e)                 = 
    funAppB (literal "scale") [exprDoc e]
 


unaryDocE :: UnaryOp -> DocE -> DocE
unaryDocE NEG   = negateU
unaryDocE BNOT  = bitwiseNotU


binDocE :: BinOp -> DocE -> DocE -> DocE
binDocE ADD         = addB
binDocE SUB         = subtractB
binDocE MUL         = multiplyB
binDocE DIV         = divideB
binDocE LOG_AND     = logicalAndB
binDocE LOG_OR      = logicalOrB 
binDocE MOD         = modB